home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / kcl / akcl / akcl-1-6.lha / V / c / array.c < prev    next >
C/C++ Source or Header  |  1991-10-07  |  15KB  |  747 lines
  1. Changes file for /usr/local/src/kcl/c/array.c
  2. Created on Mon Oct  7 20:47:14 1991
  3. Usage \n@s[Original text\n@s|Replacement Text\n@s]
  4. See the file rascal.ics.utexas.edu:/usr2/ftp/merge.c
  5. for a program to merge change files.  Anything not between
  6. "\n@s[" and  "\n@s]" is a simply a comment.
  7. This file was constructed using emacs and  merge.el
  8. Enhancements Copyright (c) W. Schelter All rights reserved.
  9.    by (Bill Schelter)  wfs@carl.ma.utexas.edu 
  10.  
  11.  
  12. ****Change:(orig (16 16 a))
  13. @s[#define    ATOTLIM        16*1024*1024
  14.  
  15. @s|#define    ATOTLIM        16*1024*1024
  16. #define WSIZE  CHAR_SIZE*sizeof(fixnum)
  17.  
  18. @s]
  19.  
  20.  
  21. ****Change:(orig (18 18 d))
  22. @s[
  23.  
  24.  
  25. @s|
  26.  
  27. @s]
  28.  
  29.  
  30. ****Change:(orig (31 31 c))
  31. @s[    else if (x == Slong_float)
  32.  
  33. @s|    else if (x == Slong_float || x == Ssingle_float || x==Sdouble_float)
  34.  
  35. @s]
  36.  
  37.  
  38. ****Change:(orig (32 32 a))
  39. @s[        return(aet_lf);
  40.  
  41. @s|        return(aet_lf);
  42.     else if (x == Sunsigned_char)
  43.       return(aet_uchar);
  44.     else if (x == Sunsigned_short)
  45.       return(aet_ushort);
  46.     else if (x == Ssigned_char)
  47.       return(aet_char);
  48.     else if (x == Ssigned_short)
  49.       return(aet_short);
  50.  
  51. @s]
  52.  
  53.  
  54. ****Change:(orig (67 67 a))
  55. @s[        return((char *)(x->a.a_self + inc));
  56.  
  57.  
  58. @s|        return((char *)(x->a.a_self + inc));
  59.  
  60.         case aet_char:
  61.         case aet_uchar:
  62.  
  63. @s]
  64.  
  65.  
  66. ****Change:(orig (70 70 a))
  67. @s[        return(x->st.st_self + inc);
  68.  
  69.  
  70. @s|        return(x->st.st_self + inc);
  71.  
  72.         case aet_short:
  73.         case aet_ushort:
  74.         return ((char *)&(USHORT(x,inc)));
  75.  
  76.  
  77. @s]
  78.  
  79.  
  80. ****Change:(orig (72 72 a))
  81. @s[        return((char *)(x->lfa.lfa_self + inc));
  82.  
  83. @s|        return((char *)(x->lfa.lfa_self + inc));
  84.           default:
  85.         FEerror("Bad array type",0);
  86.  
  87. @s]
  88.  
  89.  
  90. ****Change:(orig (76 77 c))
  91. @s[array_allocself(x, staticp)
  92. object x;
  93.  
  94. @s|static object DFLT_aet_object = Cnil;    
  95. static char DFLT_aet_ch = ' ';
  96. static char DFLT_aet_char = 0; 
  97. static int DFLT_aet_fix = 0  ;        
  98. static short DFLT_aet_short = 0;
  99. static shortfloat DFLT_aet_sf = 0.0;
  100. static longfloat DFLT_aet_lf = 0.0;    
  101.  
  102. char * default_aet_types[] =
  103. {   (char *)    &DFLT_aet_object,        /*  t  */
  104.     (char *)    &DFLT_aet_ch,            /*  string-char  */
  105.     (char *)    &DFLT_aet_fix,        /*  bit  */
  106.     (char *)    &DFLT_aet_fix,        /*  fixnum  */
  107.     (char *)    &DFLT_aet_sf,            /*  short-float  */
  108.     (char *)    &DFLT_aet_lf,            /*  long-float  */
  109.     (char *)    &DFLT_aet_char,               /* signed char */
  110.     (char *)    &DFLT_aet_char,               /* unsigned char */
  111.     (char *)    &DFLT_aet_short,              /* signed short */
  112.     (char *)    &DFLT_aet_short,             /*  unsigned short   */
  113.     };
  114.  
  115.    /* RAW_AET_PTR returns a pointer to something of raw type obtained from X
  116.       suitable for using GSET for an array of elt type TYP.
  117.       If x is the null pointer, return a default for that array element
  118.       type.
  119.       */
  120.  
  121. char *
  122. raw_aet_ptr(x,typ)
  123.      short typ;
  124.      object x;
  125. {  /* doubles are the largest raw type */
  126.   static double u;
  127.   if (x==Cnil) return default_aet_types[typ];
  128.   switch (typ){
  129. #define STORE_TYPED(pl,type,val) *((type *) pl) = (type) val; break;
  130.   case aet_object: STORE_TYPED(&u,object,x);
  131.   case aet_ch:     STORE_TYPED(&u,char, char_code(x));
  132.   case aet_bit:    STORE_TYPED(&u,fixnum, -fix(x));
  133.   case aet_fix:    STORE_TYPED(&u,fixnum, fix(x));
  134.   case aet_sf:     STORE_TYPED(&u,shortfloat, sf(x));
  135.   case aet_lf:     STORE_TYPED(&u,longfloat, lf(x));
  136.   case aet_char:   STORE_TYPED(&u, char, fix(x));
  137.   case aet_uchar:  STORE_TYPED(&u, unsigned char, fix(x));
  138.   case aet_short:  STORE_TYPED(&u, short, fix(x));
  139.   case aet_ushort: STORE_TYPED(&u,unsigned short,fix(x));
  140.   default: FEerror("bad elttype",0);
  141.   }
  142.   return (char *)&u;
  143. }
  144.  
  145.  
  146.      /* GSET copies into array ptr P1, the value
  147.     pointed to by the ptr VAL into the next N slots.  The
  148.     array type is typ.  If VAL is the null ptr, use
  149.     the default for that element type
  150.     NOTE: for type aet_bit n is the number of Words
  151.     ie (nbits +WSIZE-1)/WSIZE and the words are set.
  152.     */     
  153.  
  154. gset(p1,val,n,typ)
  155.      char *p1,*val;
  156.      int n;
  157.      int typ;
  158. { if (val==0)
  159.     val = default_aet_types[typ];
  160.     switch (typ){
  161.  
  162. #define GSET(p,n,typ,val) {typ x = *((typ *) val); GSET1(p,n,typ,x)}
  163. #define GSET1(p,n,typ,val) while (n-- > 0) \
  164.       { *((typ *) p) = val; \
  165.       p = p + sizeof(typ); \
  166.       } break;
  167.  
  168.     case aet_object: GSET(p1,n,object,val);
  169.     case aet_ch:     GSET(p1,n,char,val);
  170.       /* Note n is number of fixnum WORDS for bit */
  171.     case aet_bit:    GSET(p1,n,fixnum,val);
  172.     case aet_fix:    GSET(p1,n,fixnum,val);
  173.     case aet_sf:     GSET(p1,n,shortfloat,val);
  174.     case aet_lf:     GSET(p1,n,longfloat,val);
  175.     case aet_char:   GSET(p1,n,char,val);
  176.     case aet_uchar:  GSET(p1,n,unsigned char,val);
  177.     case aet_short:  GSET(p1,n,short,val);
  178.     case aet_ushort: GSET(p1,n,unsigned short,val);
  179.     default:         FEerror("bad elttype",0);
  180.     }
  181.   }
  182.  
  183. #ifndef COM_LENG
  184. #define COM_LENG
  185. #endif
  186. extern short aet_sizes[COM_LENG];
  187. #define W_SIZE (CHAR_SIZE*sizeof(fixnum))    
  188. /*  This copies from p1 to p2 n elements of typ 
  189. gcopy(p1,p2,n,typ)
  190. char *p1,*p2;
  191. int n,typ;
  192. { if(typ== (int)aet_bit)
  193.  
  194.     bcopy(p1,p2,(n+CHAR_SIZE-1)/CHAR_SIZE);
  195.   else
  196.     bcopy(p1,p2,n*aet_sizes[(int) typ]);
  197. }
  198. */
  199.   /* Copy n1 elements from x to y starting at x[i1]  to x[i2]
  200.      If the types of the arrays are not the same, this has
  201.      implementation dependent results.
  202.    */
  203.    
  204.      
  205. copy_array_portion(x,y,i1,i2,n1)
  206.      object x,y; int i1,i2,n1;
  207. { enum aelttype typ1=array_elttype(vs_base[0]);
  208.   enum aelttype typ2=array_elttype(vs_base[1]);
  209.   int nc;
  210.   if (typ1==aet_bit)
  211.     {if (i1 % CHAR_SIZE)
  212.      badcopy:
  213.        FEerror("Bit copies only if aligned");
  214.      else
  215.        {int rest=n1%CHAR_SIZE;
  216.     if (rest!=0 )
  217.       {if (typ2!=aet_bit)
  218.          goto badcopy;
  219.        {while(rest> 0)
  220.          { aset1(y,i2+n1-rest,(aref1(x,i1+n1-rest)));
  221.            rest--;}
  222.       }}
  223.     i1=i1/CHAR_SIZE ;
  224.     n1=n1/CHAR_SIZE;
  225.     typ1=aet_char;
  226.      }};
  227.   if (typ2==aet_bit)
  228.     {if (i2 % CHAR_SIZE)
  229.        goto badcopy;
  230.        i2=i2/CHAR_SIZE ;}
  231.   if ((typ1 ==aet_object ||
  232.        typ2  ==aet_object) && typ1 != typ2)
  233.     FEerror("Can't copy between different array types");
  234.   nc=n1 * aet_sizes[(int)typ1];
  235.   if (i1+n1 > x->a.a_dim
  236.       || ((y->a.a_dim - i2) *aet_sizes[(int)typ2]) < nc)
  237.     FEerror("Copy  out of bounds");
  238.   bcopy(x->ust.ust_self + (i1*aet_sizes[(int)typ1]),
  239.     y->ust.ust_self + (i2*aet_sizes[(int)typ2]),
  240.     nc);
  241. }
  242.  
  243. /* Copy from X to Y starting at indices i1 and i2 and
  244.    going optional N places (or array-total-size(x) -i1)
  245.    if not specified
  246.  */
  247.  
  248. siLcopy_array_portion()
  249. {int n;
  250.  if (vs_top-vs_base == 5)
  251.    {n=fix(vs_base[4]);}
  252.  else
  253.    {check_arg(4);
  254.     if(type_of(vs_base[3]) !=t_fixnum ||
  255.      type_of(vs_base[2]) !=t_fixnum )
  256.       FEerror("Need fixnum index");
  257.     n= vs_base[0]->a.a_dim - fix(vs_base[2]);
  258.   }
  259.  copy_array_portion(vs_base[0],vs_base[1],fix(vs_base[2]),
  260.             fix(vs_base[3]),n);
  261.   vs_top=vs_base+1;
  262. }
  263.  
  264.  
  265.  
  266. /* X is the header of an array.  This supplies the body which
  267.    will not be relocatable if STATICP.  If DFLT is 0, do not
  268.    initialize (the caller promises to reset these before the
  269.    next gc!).   If DFLT == Cnil then initialize to default type
  270.    for this array type.   Otherwise DFLT is an object and its
  271.    value is used to init the array */
  272.    
  273. array_allocself(x, staticp,dflt)
  274. object x,dflt;
  275.  
  276. @s]
  277.  
  278.  
  279. ****Change:(orig (81 81 c))
  280. @s[    int i, d;
  281.     char *(*f)();
  282.  
  283. @s|    int i, d;
  284.     char *(*f)(),*tmp_alloc;
  285.     enum aelttype typ;
  286.  
  287. @s]
  288.  
  289.  
  290. ****Change:(orig (88 88 c))
  291. @s[    switch (array_elttype(x)) {
  292.  
  293. @s|    typ=array_elttype(x);
  294.     switch (typ) {
  295.  
  296. @s]
  297.  
  298.  
  299. ****Change:(orig (90 92 c))
  300. @s[        x->a.a_self = (object *)(*f)(sizeof(object)*d);
  301.         for (i = 0;  i < d;  i++)
  302.             x->a.a_self[i] = Cnil;
  303.  
  304. @s|        x->a.a_self = AR_ALLOC(*f,d,object);
  305.  
  306. @s]
  307.  
  308.  
  309. ****Change:(orig (94 94 d))
  310. @s[        break;
  311.  
  312.  
  313. @s|        break;
  314.  
  315. @s]
  316.  
  317.  
  318. ****Change:(orig (96 98 c))
  319. @s[        x->st.st_self = (*f)(d);
  320.         for (i = 0;  i < d;  i++)
  321.             x->st.st_self[i] = ' ';
  322.  
  323. @s|    case aet_char:
  324.         case aet_uchar:
  325.         x->st.st_self = AR_ALLOC(*f,d,char);
  326.  
  327. @s]
  328.  
  329.  
  330. ****Change:(orig (100 100 c))
  331. @s[        break;
  332.  
  333.  
  334. @s|        break;
  335.         case aet_short:
  336.         case aet_ushort:
  337.         x->ust.ust_self = (unsigned char *) AR_ALLOC(*f,d,short);
  338.         break;
  339.  
  340. @s]
  341.  
  342.  
  343. ****Change:(orig (102 105 c))
  344. @s[        d = (d+7)/8;
  345.         x->bv.bv_self = (*f)(d);
  346.         for (i = 0;  i < d;  i++)
  347.             x->bv.bv_self[i] = '\0';
  348.  
  349. @s|        d = (d+W_SIZE-1)/W_SIZE;
  350.  
  351. @s]
  352.  
  353.  
  354. ****Change:(orig (107 108 d))
  355. @s[        x->bv.bv_offset = 0;
  356.         break;
  357.  
  358.  
  359. @s|        x->bv.bv_offset = 0;
  360.  
  361. @s]
  362.  
  363.  
  364. ****Change:(orig (110 112 c))
  365. @s[        x->fixa.fixa_self = (fixnum *)(*f)(sizeof(fixnum)*d);
  366.         for (i = 0;  i < d;  i++)
  367.             x->fixa.fixa_self[i] = 0;
  368.  
  369. @s|        x->fixa.fixa_self = AR_ALLOC(*f,d,fixnum);
  370.  
  371. @s]
  372.  
  373.  
  374. ****Change:(orig (114 114 d))
  375. @s[        break;
  376.  
  377.  
  378. @s|        break;
  379.  
  380. @s]
  381.  
  382.  
  383. ****Change:(orig (116 118 c))
  384. @s[        x->sfa.sfa_self = (shortfloat *)(*f)(sizeof(shortfloat)*d);
  385.         for (i = 0;  i < d;  i++)
  386.             x->sfa.sfa_self[i] = 0.0;
  387.  
  388. @s|        x->sfa.sfa_self = AR_ALLOC(*f,d,shortfloat);
  389.  
  390. @s]
  391.  
  392.  
  393. ****Change:(orig (120 120 d))
  394. @s[        break;
  395.  
  396.  
  397. @s|        break;
  398.  
  399. @s]
  400.  
  401.  
  402. ****Change:(orig (122 124 c))
  403. @s[        x->lfa.lfa_self = (longfloat *)(*f)(sizeof(longfloat)*d);
  404.         for (i = 0;  i < d;  i++)
  405.             x->lfa.lfa_self[i] = 0.0;
  406.  
  407. @s|        x->lfa.lfa_self = AR_ALLOC(*f,d,longfloat);
  408.  
  409. @s]
  410.  
  411.  
  412. ****Change:(orig (126 126 a))
  413. @s[        break;
  414.     }
  415.  
  416. @s|        break;
  417.     }
  418.     if(dflt!=0) gset(x->st.st_self,raw_aet_ptr(dflt,typ),d,typ);
  419.  
  420. @s]
  421.  
  422.  
  423. ****Change:(orig (154 154 a))
  424. @s[        return(make_fixnum(x->fixa.fixa_self[index]));
  425.  
  426.  
  427. @s|        return(make_fixnum(x->fixa.fixa_self[index]));
  428.  
  429.  
  430. #define UCHAR(x,index) ((x)->ust.ust_self[index])
  431.  
  432.     case aet_uchar:
  433.         return(make_fixnum((fixnum)(UCHAR(x,index))));
  434.   
  435.     case aet_char:
  436.         return(make_fixnum((fixnum)(SIGNED_CHAR(UCHAR(x,index)))));
  437.         
  438.         case aet_short:
  439.       return(make_fixnum((fixnum)(short)USHORT(x,index)));
  440.  
  441.         case aet_ushort:
  442.       return(make_fixnum((fixnum)USHORT(x,index)));
  443.  
  444.  
  445. @s]
  446.  
  447.  
  448. ****Change:(orig (199 199 a))
  449. @s[        x->fixa.fixa_self[index] = fixint(value);
  450.         break;
  451.  
  452. @s|        x->fixa.fixa_self[index] = fixint(value);
  453.         break;
  454.         
  455.     case aet_char:
  456.         case aet_uchar:
  457.         x->ust.ust_self[index]=(unsigned char)fixint(value);
  458.         break;
  459.  
  460. @s]
  461.  
  462.  
  463. ****Change:(orig (200 200 a))
  464. @s[
  465.  
  466. @s|
  467.     case aet_short:
  468.         case aet_ushort:
  469.         USHORT(x,index) = (unsigned short)fixint(value);
  470.         break;
  471.  
  472.  
  473. @s]
  474.  
  475.  
  476. ****Change:(orig (320 320 c))
  477. @s[        from->st.st_self = array_address(to, j);
  478. }
  479.  
  480. /*
  481.  
  482. @s|        from->st.st_self = array_address(to, j);
  483. }
  484.  
  485. /*  (setq a (make-array 2 :displaced-to (setq b (make-array 4 )))) {  A->displ = (B), B->displ=(nil A)}
  486.  
  487. @s]
  488.  
  489.  
  490. ****Change:(orig (327 328 c))
  491. @s[    object to = from->a.a_displaced->c.c_car;
  492.  
  493.  
  494. @s|    object to;
  495.     
  496.       /* if the cons is free, neither the FROM nor the TO array will
  497.          survive the gc (or we would have marked this), and we can
  498.          skip undisplacing */
  499.     
  500.     if (from->a.a_displaced->d.m == FREE) return;
  501.     to= from->a.a_displaced->c.c_car;
  502.     
  503.  
  504. @s]
  505.  
  506.  
  507. ****Change:(orig (332 336 c))
  508. @s[    for (p = &(to->a.a_displaced->c.c_cdr);;  p = &((*p)->c.c_cdr))
  509.         if ((*p)->c.c_car == from) {
  510.             *p = (*p)->c.c_cdr;
  511.             return;
  512.  
  513. @s,        }
  514.  
  515. @s|    for (p = &(to->a.a_displaced->c.c_cdr);;  p = &((*p)->c.c_cdr)){
  516.  
  517.       if ((*p)->d.m == FREE) return;
  518.       /* During the sweep phase we sometimes null out the rest of this list
  519.          if the array is being displaced.
  520.          */
  521.       if (*p == Cnil) return; 
  522.       if ((*p)->c.c_car == from) {
  523.         *p = (*p)->c.c_cdr;
  524.         return;
  525.         }}
  526.  
  527. @s]
  528.  
  529.  
  530. ****Change:(orig (410 410 c))
  531. @s[                        displaced-to displaced-index-offset
  532.                     static
  533.  
  534. @s|                        displaced-to displaced-index-offset
  535.                     static initial-element
  536.  
  537. @s]
  538.  
  539.  
  540. ****Change:(orig (418 418 c))
  541. @s[    r = vs_top - vs_base - 5;
  542.  
  543. @s|    r = vs_top - vs_base - 6;
  544.  
  545. @s]
  546.  
  547.  
  548. ****Change:(orig (428 428 c))
  549. @s[    x->a.a_dims = (int *)alloc_relblock(sizeof(int)*r);
  550.  
  551. @s|    x->a.a_dims = AR_ALLOC(alloc_relblock,r,int);
  552.  
  553. @s]
  554.  
  555.  
  556. ****Change:(orig (434 434 c))
  557. @s[        if ((j = fixnnint(vs_base[i+5])) > ADIMLIM) {
  558.  
  559. @s|        if ((j = fixnnint(vs_base[i+6])) > ADIMLIM) {
  560.  
  561. @s]
  562.  
  563.  
  564. ****Change:(orig (437 437 c))
  565. @s[                2, vs_head, vs_base[i+5]);
  566.  
  567. @s|                2, vs_head, vs_base[i+6]);
  568.  
  569. @s]
  570.  
  571.  
  572. ****Change:(orig (449 449 c))
  573. @s[        array_allocself(x, vs_base[4] != Cnil);
  574.  
  575. @s|        array_allocself(x, vs_base[4] != Cnil,vs_base[5]);
  576.  
  577. @s]
  578.  
  579.  
  580. ****Change:(orig (460 460 c))
  581. @s[                displaced-to displaced-index-offset
  582.                     static)
  583.  
  584. @s|                displaced-to displaced-index-offset
  585.                     static &optional initial-element)
  586.  
  587. @s]
  588.  
  589.  
  590. ****Change:(orig (465 465 a))
  591. @s[    int d, i, j;
  592.     object x;
  593.  
  594. @s|    int d, i, j;
  595.     object x;
  596.     object dflt=Cnil;
  597.  
  598. @s]
  599.  
  600.  
  601. ****Change:(orig (467 468 c))
  602. @s[    enum aelttype aet;
  603.  
  604.     check_arg(7);
  605.  
  606. @s|    enum aelttype aet;
  607.         if (vs_top-vs_base == 8)
  608.       {dflt=vs_base[7];}
  609.     else {check_arg(7);}
  610.  
  611. @s]
  612.  
  613.  
  614. ****Change:(orig (488 488 c))
  615. @s[        array_allocself(x, vs_base[6] != Cnil);
  616.  
  617. @s|        array_allocself(x, vs_base[6] != Cnil,dflt);
  618.  
  619. @s]
  620.  
  621.  
  622. ****Change:(orig (604 604 a))
  623. @s[        vs_base[0] = Sfixnum;
  624.         break;
  625.  
  626.  
  627. @s|        vs_base[0] = Sfixnum;
  628.         break;
  629.  
  630.         case aet_char:
  631.         vs_base[0]= Ssigned_char;
  632.         break;
  633.  
  634.         case aet_uchar:
  635.         vs_base[0]= Sunsigned_char;
  636.         break;
  637.         case aet_short:
  638.         vs_base[0]= Ssigned_short;
  639.         break;
  640.         case aet_ushort:
  641.         vs_base[0]= Sunsigned_short;
  642.         break;
  643.  
  644. @s]
  645.  
  646.  
  647. ****Change:(orig (774 774 a))
  648. @s[    object old, new, displaced, dlist;
  649.     int diff;
  650.  
  651. @s|    object old, new, displaced, dlist;
  652.     int diff;
  653.     struct dummy fw;
  654.  
  655. @s]
  656.  
  657.  
  658. ****Change:(orig (777 777 d))
  659. @s[
  660.     check_arg(2);
  661.  
  662.  
  663. @s|
  664.     check_arg(2);
  665.  
  666. @s]
  667.  
  668.  
  669. ****Change:(orig (779 779 a))
  670. @s[    old = vs_base[0];
  671.     new = vs_base[1];
  672.  
  673. @s|    old = vs_base[0];
  674.     new = vs_base[1];
  675.     fw = old->d;
  676.  
  677.  
  678. @s]
  679.  
  680.  
  681. ****Change:(orig (784 784 c))
  682. @s[    if (!old->a.a_adjustable)
  683.  
  684. @s|/*   Common lisp now allows adjustment of non adjustable arrays CLTLII 17.6
  685.      if (!old->a.a_adjustable)
  686.  
  687. @s]
  688.  
  689.  
  690. ****Change:(orig (785 785 a))
  691. @s[        FEerror("~S is not adjustable.", 1, old);
  692.  
  693. @s|        FEerror("~S is not adjustable.", 1, old);
  694. */        
  695.  
  696. @s]
  697.  
  698.  
  699. ****Change:(orig (806 806 a))
  700. @s[    default:
  701.         goto CANNOT;
  702.     }
  703.  
  704. @s|    default:
  705.         goto CANNOT;
  706.     }
  707.     
  708.     /* restore the s and m fields overwritten by above assignments  */
  709.     old->d = fw;
  710.  
  711. @s]
  712.  
  713.  
  714. ****Change:(orig (807 807 a))
  715. @s[    old->a.a_displaced = displaced;
  716.  
  717. @s|    old->a.a_displaced = displaced;
  718.     /* prevent having two arrays with the same body--which are not related
  719.         that would cause the gc to try to copy both arrays and there might
  720.        not be enough space. */
  721.     new->a.a_dim=0;
  722.     new->a.a_self=0;
  723.  
  724. @s]
  725.  
  726.  
  727. ****Change:(orig (847 847 c))
  728. @s[    make_si_function("DISPLACED-ARRAY-P", siLdisplaced_array_p);
  729.  
  730.  
  731. @s|    make_si_function("DISPLACED-ARRAY-P", siLdisplaced_array_p);
  732.     make_si_constant("CHAR-SIZE",make_fixnum(CHAR_SIZE));
  733.     make_si_constant("SHORT-SIZE",make_fixnum(CHAR_SIZE*sizeof(short)));
  734.  
  735. @s]
  736.  
  737.  
  738. ****Change:(orig (850 850 c))
  739. @s[    make_si_function("SVSET", siLsvset);
  740.  
  741.  
  742. @s|    make_si_function("SVSET", siLsvset);
  743.     make_si_function("COPY-ARRAY-PORTION",siLcopy_array_portion);
  744.  
  745. @s]
  746.  
  747.